Attribute VB_Name = "modBrowseDirectory"
Option Explicit

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'For dir chooser
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_USENEWUI = &H40
Private Const BIF_BROWSEINCLUDEFILES = &H4000
'
'Private Const OFN_ALLOWMULTISELECT = &H200
'Private Const OFN_CREATEPROMPT = &H2000
'Private Const OFN_DONTADDTORECENT = &H2000000
'Private Const OFN_ENABLEHOOK = &H20
'Private Const OFN_ENABLEINCLUDENOTIFY = &H400000
'Private Const OFN_ENABLESIZING = &H800000
'Private Const OFN_ENABLETEMPLATE = &H40
'Private Const OFN_ENABLETEMPLATEHANDLE = &H80
'Private Const OFN_EX_NOPLACESBAR = &H1
'Private Const OFN_EXPLORER = &H80000
'Private Const OFN_EXTENSIONDIFFERENT = &H400
'Private Const OFN_FILEMUSTEXIST = &H1000
'Private Const OFN_FORCESHOWHIDDEN = &H10000000
'Private Const OFN_HIDEREADONLY = &H4
'Private Const OFN_LONGNAMES = &H200000
'Private Const OFN_NOCHANGEDIR = &H8
'Private Const OFN_NODEREFERENCELINKS = &H100000
'Private Const OFN_NOLONGNAMES = &H40000
'Private Const OFN_NOREADONLYRETURN = &H8000
'Private Const OFN_NOTESTFILECREATE = &H10000
'Private Const OFN_NOVALIDATE = &H100
'Private Const OFN_OVERWRITEPROMPT = &H2
'Private Const OFN_PATHMUSTEXIST = &H800
'Private Const OFN_READONLY = &H1
'Private Const OFN_SHAREAWARE = &H4000
'Private Const OFN_SHAREFALLTHROUGH = 2
'Private Const OFN_SHARENOWARN = 1
'Private Const OFN_SHAREWARN = 0
'Private Const OFN_SHOWHELP = &H10
'Private Const OFN_USEMONIKERS = &H1000000

Private Const MAX_PATH = 260

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function SHGetPathFromIdlist Lib "shell32" Alias "SHGetPathFromIDList" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
'
Private Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpBI As browseinfo) As Long
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_USER = &H400
Private Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Private Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
Private Const BFFM_INITIALIZED As Long = 1
Private Const LMEM_FIXED = &H0
Private Const LMEM_ZEROINIT = &H40
Private Const lPtr = (LMEM_FIXED + LMEM_ZEROINIT)

Private Type browseinfo
    hOwner As Long
    pidlroot As Long
    pszdisplayname As String
    lpsztitle As String
    uiFlags As Long
    lpfnCallBack As Long
    lParam As Long
    iimage As Long
End Type

Private Function MyAddressOf(AddressOfX) As Long
    MyAddressOf = AddressOfX
End Function
'-------------------------------------------------------------------
'For Dir browser
'-------------------------------------------------------------------
Public Function BrowseDirectory(ByVal hWnd As Long, strPrompt As String, Optional InitDir As String, Optional ByVal dirOnly As Boolean = True, Optional ByVal newUI As Boolean = True) As String
On Error GoTo ehBrowseForFolder
    Dim intNull As Integer
    Dim lngIDList As Long, lngResult As Long
    Dim strPath As String
    Dim udtBI As browseinfo
    Dim ret As Long

    With udtBI
        .hOwner = hWnd
        .lpsztitle = strPrompt

        If Len(InitDir) > 0 Then
            .lpfnCallBack = MyAddressOf(AddressOf BrowseForFolders_CallbackProc)
            ret = LocalAlloc(lPtr, VBA.Len(InitDir) + 1)
            CopyMemory ByVal ret, ByVal InitDir, Len(InitDir) + 1
            .lParam = ret
        End If
        
        If newUI Then
            .uiFlags = .uiFlags Or BIF_USENEWUI
        End If
        
        If dirOnly Then
            .uiFlags = .uiFlags Or BIF_RETURNONLYFSDIRS
        Else
            .uiFlags = .uiFlags Or BIF_BROWSEINCLUDEFILES
        End If
        
        
        .uiFlags = .uiFlags Or BIF_RETURNFSANCESTORS
    End With
    lngIDList = SHBrowseForFolder(udtBI)
    If lngIDList <> 0 Then
        strPath = String(MAX_PATH, Chr(0))
        lngResult = SHGetPathFromIdlist(lngIDList, strPath)
        Call CoTaskMemFree(lngIDList)
        intNull = InStr(strPath, vbNullChar)
        If intNull > 0 Then
            strPath = Left$(strPath, intNull - 1)
        End If
    End If
    BrowseDirectory = strPath
    Exit Function
ehBrowseForFolder:
    BrowseDirectory = Empty
End Function

Private Function BrowseForFolders_CallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
    If uMsg = BFFM_INITIALIZED Then
        SendMessage hWnd, BFFM_SETSELECTIONA, True, ByVal lpData
    End If
End Function
